home *** CD-ROM | disk | FTP | other *** search
/ Games of Daze / Infomagic - Games of Daze (Summer 1995) (Disc 1 of 2).iso / x2ftp / msdos / demosrc / cfsource / mcga.pas < prev    next >
Pascal/Delphi Source File  |  1994-12-09  |  44KB  |  1,905 lines
  1. {$A+,G+,R-,S-}
  2. UNIT MCGA;   { Copyright by Stefan Ohrhallinger in 1991,92,93,94 }
  3.              { aka »The Faker« of AARDVARK }
  4. INTERFACE
  5. CONST
  6.      Up=0;
  7.      Right=1;
  8.      Down=2;
  9.      Left=3;
  10.  
  11. PROCEDURE SetPixel(X,Y:Word; C:Byte);
  12. FUNCTION GetPixel(X,Y:Word):Byte;
  13. PROCEDURE DrawLineH(X1,X2,Y1:Word; C:Byte);
  14. PROCEDURE DrawLineV(X1,Y1,Y2:Word; C:Byte);
  15. PROCEDURE DrawLine(X1,Y1,X2,Y2:Integer; C:Byte);
  16. PROCEDURE SetColor(Nr,R,G,B:Byte);
  17. PROCEDURE GetColor(Nr:Byte; VAR R,G,B:Byte);
  18. FUNCTION PaintChar(Ch,X,Y:Integer; C:Byte):Boolean;
  19. PROCEDURE GrWrite(X,Y:Integer; C:Byte; S:String);
  20. PROCEDURE LoadFont(Nr:Byte; Name:String);
  21. PROCEDURE SetText(Nr:Byte; MultX,DivX,MultY,DivY:Byte);
  22. PROCEDURE DrawPolygon(Count:Integer; VAR P; C:Byte);
  23. PROCEDURE Fill(X,Y:Integer; C:Byte);  { Nur die selbe Farbe ersetzen }
  24. PROCEDURE Flood(X,Y:Integer; C,C2:Byte);  { Anfärben bis zur Randfarbe C2 }
  25. PROCEDURE MCGAOn;
  26. PROCEDURE MCGAOff;
  27. PROCEDURE FillPolygon(Size:Integer; VAR P1; C:Byte);
  28. PROCEDURE Ellipse(MX,MY,A,B:Integer; C:Byte);
  29. PROCEDURE FillEllipse(MX,MY,A,B:Integer; C:Byte);
  30. PROCEDURE Circle(X,Y,R:Integer; C:Byte);
  31. PROCEDURE FillCircle(X,Y,R:Integer; C:Byte);
  32. PROCEDURE RotateArray(VAR P; Count,MX,MY:Integer; Winkel:Real);
  33. PROCEDURE N4eck(N,X,Y,R1,R2:Integer; C:Byte);
  34. PROCEDURE Neck(N,X,Y,A,B:Integer; Drehen:Real);
  35. PROCEDURE DrawRing(X,Y,R1,R2:Integer; C:Byte);
  36. PROCEDURE FillRing(X,Y,R1,R2:Integer; C:Byte);
  37. PROCEDURE SetFrameColor(C:Byte);
  38. PROCEDURE RecTangle(X1,Y1,X2,Y2:Integer; C:Byte);
  39. PROCEDURE GetImage(X1,Y1,X2,Y2:Integer; VAR P);
  40. PROCEDURE PutImage(X1,Y1:Integer; VAR P);
  41. PROCEDURE PutImagePart(X1,Y1,XS2,YS2:Integer; VAR P);
  42. PROCEDURE FillBlock(X1,Y1,X2,Y2:Integer; C:Byte);
  43. PROCEDURE ScrollLeft(X1,Y1,X2,Y2:Word);
  44. PROCEDURE ScrollRight(X1,Y1,X2,Y2:Word);
  45. PROCEDURE ScrollUp(X1,Y1,X2,Y2:Word);
  46. PROCEDURE ScrollDown(X1,Y1,X2,Y2:Word);
  47. PROCEDURE Scroll(Direction:Byte; X1,Y1,X2,Y2:Word);
  48. PROCEDURE SwitchOff;
  49. PROCEDURE SwitchOn;
  50. PROCEDURE LoadPalette(DateiName:String);
  51. PROCEDURE SavePalette(DateiName:String);
  52. PROCEDURE LoadScreen(DateiName:String);
  53. PROCEDURE SaveScreen(DateiName:String);
  54. PROCEDURE BCircle(X,Y,R:Integer; C:Byte);
  55. PROCEDURE BFillCircle(X,Y,R:Integer; C:Byte);
  56. PROCEDURE Split(Row:Integer);
  57. PROCEDURE ScrollText(Nr:Word);
  58. PROCEDURE SetStart(S:Word);
  59. PROCEDURE VerticalRetrace;
  60. PROCEDURE WaitScreen;
  61. PROCEDURE WaitRetrace;
  62. PROCEDURE SetOffset(B:Byte);
  63. PROCEDURE LoadSprite(DateiName:String; VAR P);
  64. PROCEDURE SaveSprite(DateiName:String; VAR P);
  65. FUNCTION SpriteXSize(Sprite:Pointer):Word;
  66. FUNCTION SpriteYSize(Sprite:Pointer):Word;
  67. FUNCTION SpriteSize(Sprite:Pointer):Word;
  68. PROCEDURE FillScreen(C:Byte);
  69. PROCEDURE SetChain4;
  70. PROCEDURE ClearChain4;
  71. PROCEDURE CharHeight(B:Byte);
  72. PROCEDURE Wait4Line;
  73. PROCEDURE CLI;
  74. PROCEDURE STI;
  75. PROCEDURE PutImage4(X1,Y1:Integer; VAR P);
  76. PROCEDURE SetWriteMap(Map:Byte);
  77. PROCEDURE SetWriteMode(M:Byte);
  78. PROCEDURE Unchain;
  79. PROCEDURE Rechain;
  80. PROCEDURE ClearScreen;
  81. PROCEDURE SetModeNr(Nr:Word);
  82. PROCEDURE Set16Pal(Nr:Byte);
  83. PROCEDURE Init16Pal;
  84. PROCEDURE SetLineRepeat(Nr:Byte);
  85. PROCEDURE TextMode;
  86. PROCEDURE Init13X;
  87. PROCEDURE SetReadMap(Map:Byte);
  88. PROCEDURE DrawLineH4(X1,X2,Y1:Word; C:Byte);
  89. PROCEDURE DrawLineV4(X1,Y1,Y2:Word; C:Byte);
  90. PROCEDURE SetHorizOfs(Count:Byte);
  91.  
  92. {
  93. PROCEDURE SetModeReg(Reg:String);
  94. PROCEDURE SetDoubleLines(Ok:Boolean);
  95. PROCEDURE SetPal(VAR A);
  96. PROCEDURE ReducePal(VAR A);
  97. }
  98.  
  99. IMPLEMENTATION
  100. CONST
  101.      MaxFont=4;
  102.      FontName:ARRAY[1..MaxFont] OF String[4]=('TRIP','LITT','SANS','GOTH');
  103.      VekMax=100;
  104.      X_zu_Y=0.69;
  105. TYPE
  106.     FontType=RECORD
  107.                    FBuf:ARRAY[0..16000] OF Byte;
  108.                    WPtr:^Word;
  109.                    DataOffs,MinChar,TBStart,TblSize,WidthTbl,VecStart,CUp,CDown:Integer;
  110.                    GLine,Index,CharWidth:Integer;
  111.              END;
  112. VAR
  113.    Font:ARRAY[1..4] OF ^FontType;
  114.    FontNr,MX,DX,MY,DY:Byte;
  115.    CurrMode,OldMode:Byte;
  116.  
  117. PROCEDURE SetPixel(X,Y:Word; C:Byte);
  118. BEGIN
  119.      ASM
  120.         mov ax,$a000
  121.         mov es,ax
  122.         mov bx,x
  123.         mov dx,y
  124.         xchg dh,dl
  125.         mov al,c
  126.         mov di,dx
  127.         shr di,1
  128.         shr di,1
  129.         add di,dx
  130.         add di,bx
  131.         stosb
  132.      END;
  133. END;
  134.  
  135. FUNCTION GetPixel(X,Y:Word):Byte;
  136. BEGIN
  137.      ASM
  138.         mov ax,$a000
  139.         mov es,ax
  140.         mov bx,x
  141.         mov dx,y
  142.         mov di,dx
  143.         shl di,1
  144.         shl di,1
  145.         add di,dx
  146.         mov cl,6
  147.         shl di,cl
  148.         add di,bx
  149.         mov al,es:[di]
  150.         mov [bp-1],al
  151.      END;
  152. END;
  153.  
  154. PROCEDURE DrawLineH(X1,X2,Y1:Word; C:Byte);
  155. BEGIN
  156.      ASM
  157.         mov ax,$a000
  158.         mov es,ax
  159.         mov ax,y1
  160.         mov di,ax
  161.         shl di,1
  162.         shl di,1
  163.         add di,ax
  164.         mov cl,6
  165.         shl di,cl
  166.         mov bx,x1
  167.         mov dx,x2
  168.         cmp bx,dx
  169.         jl @1
  170.         xchg bx,dx
  171. @1:     inc dx
  172.         add di,bx
  173.         mov cx,dx
  174.         sub cx,bx
  175.         shr cx,1
  176.         mov al,c
  177.         mov ah,al
  178.         ror bx,1
  179.         jnb @2
  180.         stosb
  181.         ror dx,1
  182.         jnb @3
  183.         dec cx
  184. @3:     rol dx,1
  185. @2:     rep
  186.         stosw
  187.         ror dx,1
  188.         jnb @4
  189.         stosb
  190. @4:
  191.      END;
  192. END;
  193.  
  194. PROCEDURE DrawLineV(X1,Y1,Y2:Word; C:Byte);
  195. BEGIN
  196.      ASM
  197.         mov ax,x1
  198.         mov bx,y1
  199.         mov dx,y2
  200.         cmp bx,dx
  201.         jl @1
  202.         xchg bx,dx
  203. @1:     mov di,bx
  204.         shl di,1
  205.         shl di,1
  206.         add di,bx
  207.         mov cl,6
  208.         shl di,cl
  209.         add di,ax
  210.         mov cx,$a000
  211.         mov es,cx
  212.         mov cx,dx
  213.         sub cx,bx
  214.         inc cx
  215.         mov al,c
  216.         mov bx,$13f
  217. @2:     stosb
  218.         add di,bx
  219.         loop @2
  220.      END;
  221. END;
  222.  
  223. PROCEDURE DrawLine(X1,Y1,X2,Y2:Integer; C:Byte);
  224. BEGIN
  225.      ASM
  226.         mov al,c
  227.         xor ah,ah
  228.         mov si,ax
  229.         mov ax,x1
  230.         cmp ax,319
  231.         ja @Ende
  232.         mov bx,x2
  233.         cmp bx,319
  234.         ja @Ende
  235.         mov cx,y1
  236.         cmp cx,199
  237.         ja @Ende
  238.         mov dx,y2
  239.         cmp dx,199
  240.         ja @Ende
  241.         cmp ax,bx
  242.         jnz @weiter
  243.         cmp cx,dx
  244.         jnz @vertical
  245.         push ax
  246.         push cx
  247.         push si
  248.         call setpixel
  249.         jmp @ende
  250. @weiter:cmp cx,dx
  251.         jnz @weiter2
  252.         push ax
  253.         push bx
  254.         push cx
  255.         push si
  256.         call drawlineh
  257.         jmp @ende
  258. @vertical:push ax
  259.         push cx
  260.         push dx
  261.         push si
  262.         call drawlinev
  263.         jmp @ende
  264. @weiter2:cmp cx,dx
  265.         jbe @1
  266.         xchg cx,dx
  267.         xchg ax,bx
  268. @1:     mov di,cx
  269.         shl di,1
  270.         shl di,1
  271.         add di,cx
  272.         push si
  273.         mov si,bx
  274.         mov bx,dx
  275.         sub bx,cx
  276.         mov cl,06
  277.         shl di,cl
  278.         add di,ax
  279.         mov dx,si
  280.         pop si
  281.         sub dx,ax
  282.         mov ax,$a000
  283.         mov es,ax
  284.         mov ax,si
  285.         push bp
  286.         or dx,0
  287.         jge @jmp1
  288.         neg dx
  289.         cmp dx,bx
  290.         jbe @jmp3
  291.         mov cx,dx
  292.         inc cx
  293.         mov si,dx
  294.         shr si,1
  295.         std
  296.         mov bp,320
  297. @1c:    stosb
  298. @1b:    or si,si
  299.         jge @1a
  300.         add di,bp
  301.         add si,dx
  302.         jmp @1b
  303. @1a:    sub si,bx
  304.         loop @1c
  305.         jmp @Ende2
  306. @jmp3:  mov cx,bx
  307.         inc cx
  308.         mov si,bx
  309.         neg si
  310.         sar si,1
  311.         cld
  312.         mov bp,319
  313. @2c:    stosb
  314. @2b:    or si,si
  315.         jl @2a
  316.         sub si,bx
  317.         dec di
  318.         jmp @2b
  319. @2a:    add di,bp
  320.         add si,dx
  321.         loop @2c
  322.         jmp @Ende2
  323. @jmp1:  cmp dx,bx
  324.         jbe @jmp4
  325.         mov cx,dx
  326.         inc cx
  327.         mov si,dx
  328.         shr si,1
  329.         cld
  330.         mov bp,320
  331. @3c:    stosb
  332. @3b:    or si,si
  333.         jge @3a
  334.         add di,bp
  335.         add si,dx
  336.         jmp @3b
  337. @3a:    sub si,bx
  338.         loop @3c
  339.         jmp @Ende2
  340. @jmp4:  mov cx,bx
  341.         inc cx
  342.         mov si,bx
  343.         neg si
  344.         sar si,1
  345.         std
  346.         mov bp,321
  347. @4c:    stosb
  348. @4b:    or si,si
  349.         jl @4a
  350.         sub si,bx
  351.         inc di
  352.         jmp @4b
  353. @4a:    add di,bp
  354.         add si,dx
  355.         loop @4c
  356. @Ende2: pop bp
  357.         cld
  358. @Ende:
  359.      END;
  360. END;
  361.  
  362. PROCEDURE SetColor(Nr,R,G,B:Byte);
  363. BEGIN
  364.      Port[$3C8]:=Nr;
  365.      Port[$3C9]:=R;
  366.      Port[$3C9]:=G;
  367.      Port[$3C9]:=B;
  368. END;
  369.  
  370. PROCEDURE GetColor(Nr:Byte; VAR R,G,B:Byte);
  371. BEGIN
  372.      Port[$3C7]:=Nr;
  373.      R:=Port[$3C9];
  374.      G:=Port[$3C9];
  375.      B:=Port[$3C9];
  376. END;
  377.  
  378. FUNCTION PaintChar(Ch,X,Y:Integer; C:Byte):Boolean;
  379. VAR
  380.    XVec,YVec,Func,GraphX,GraphY:Integer;
  381. BEGIN
  382.      PaintChar:=FALSE;
  383.      WITH Font[FontNr]^ DO
  384.      BEGIN
  385.           IF (Ch<MinChar) OR (Ch>MinChar+TblSize-1) THEN
  386.              Exit;
  387.           Index:=VecStart+FBuf[TBStart+(Ch-MinChar)*2]+FBuf[TBStart+(Ch-MinChar)*2+1]*256;
  388.           REPEAT
  389.                 XVec:=ShortInt(FBuf[Index]);
  390.                 YVec:=ShortInt(FBuf[Index+1]);
  391.                 Inc(Index,2);
  392.                 Func:=(XVec AND $80) SHR 6+(YVec AND $80) SHR 7;
  393.                 XVec:=XVec AND $7F;
  394.                 YVec:=YVec AND $7F;
  395.                 IF XVec>=$40 THEN
  396.                    XVec:=-128+XVec;
  397.                 IF YVec>=$40 THEN
  398.                    YVec:=-128+YVec;
  399.                 IF MX<>1 THEN
  400.                    XVec:=XVec*MX;
  401.                 IF DX<>1 THEN
  402.                    XVec:=XVec DIV DX;
  403.                 IF MY<>1 THEN
  404.                    YVec:=YVec*MY;
  405.                 IF DY<>1 THEN
  406.                    YVec:=YVec DIV DY;
  407.                 CASE Func OF
  408.                      2:BEGIN
  409.                             GraphX:=X+XVec;
  410.                             GraphY:=CUp+Y-YVec;
  411.                        END;
  412.                      3:BEGIN
  413.                             DrawLine(X+XVec,CUp+Y-YVec,GraphX,GraphY,C);
  414.                             GraphX:=X+XVec;
  415.                             GraphY:=CUp+Y-YVec;
  416.                        END;
  417.                 END;
  418.           UNTIL Func=0;
  419.      END;
  420.      PaintChar:=TRUE;
  421. END;
  422.  
  423. PROCEDURE GrWrite(X,Y:Integer; C:Byte; S:String);
  424. VAR
  425.    I:Byte;
  426. BEGIN
  427.      WITH Font[FontNr]^ DO
  428.      BEGIN
  429.           FOR I:=1 TO Ord(S[0]) DO
  430.           BEGIN
  431.                IF X+FBuf[WidthTbl+Ord(S[I])-MinChar]*MX DIV DX>319 THEN
  432.                BEGIN
  433.                     X:=0;
  434.                     IF Y+(CUp-CDown)*MY DIV DY>319 THEN
  435.                        Exit;
  436.                     Inc(Y,(CUp-CDown)*MY DIV DY);
  437.                END;
  438.                IF PaintChar(Ord(S[I]),X,Y,C) THEN
  439.                   Inc(X,(FBuf[WidthTbl+Ord(S[I])-MinChar])*MX DIV DX);
  440.           END;
  441.      END;
  442. END;
  443.  
  444. PROCEDURE LoadFont(Nr:Byte; Name:String);
  445. VAR
  446.    X:Integer;
  447.    ChrFile:File;
  448. BEGIN
  449.      New(Font[Nr]);
  450.      WITH Font[Nr]^ DO
  451.      BEGIN
  452.           Assign(ChrFile,Name+'.CHR');
  453.           Reset(ChrFile,1);
  454.           BlockRead(ChrFile,FBuf,FileSize(ChrFile));
  455.           Close(ChrFile);
  456.           X:=0;
  457.           WHILE (X<$80) AND (FBuf[X]<>$1A) DO
  458.                 Inc(X);
  459.           Inc(X);
  460.           DataOffs:=FBuf[X]+FBuf[X+1] SHL 8;
  461.           TblSize:=FBuf[DataOffs+1];
  462.           MinChar:=FBuf[DataOffs+4];
  463.           CUp:=FBuf[DataOffs+8];
  464.           CDown:=ShortInt(FBuf[DataOffs+$0A]);
  465.           TBStart:=DataOffs+$10;
  466.           WidthTbl:=TBStart+TblSize SHL 1;
  467.           WPtr:=@FBuf[DataOffs+5];
  468.           VecStart:=WPtr^+DataOffs;
  469.      END;
  470. END;
  471.  
  472. PROCEDURE SetText(Nr:Byte; MultX,DivX,MultY,DivY:Byte);
  473. BEGIN
  474.      IF (Nr<1) OR (Nr>MaxFont) THEN
  475.         Exit;
  476.      IF Font[Nr]=NIL THEN
  477.         LoadFont(Nr,FontName[Nr]);
  478.      FontNr:=Nr;
  479.      MX:=MultX;
  480.      DX:=DivX;
  481.      MY:=MultY;
  482.      DY:=DivY;
  483. END;
  484.  
  485. PROCEDURE DrawPolygon(Count:Integer; VAR P; C:Byte);
  486. TYPE
  487.     PunkteArray=ARRAY[1..16383,1..2] OF Integer;
  488. VAR
  489.    A:PunkteArray ABSOLUTE P;
  490.    I:Integer;
  491. BEGIN
  492.      DrawLine(A[Count,1],A[Count,2],A[1,1],A[1,2],C);
  493.      FOR I:=2 TO Count DO
  494.          DrawLine(A[I-1,1],A[I-1,2],A[I,1],A[I,2],C);
  495. END;
  496.  
  497. PROCEDURE Fill(X,Y:Integer; C:Byte);  { Nur die selbe Farbe ersetzen }
  498. VAR
  499.    C2:Byte;
  500.  
  501.    PROCEDURE Suchen(L,R,Y:Integer; UpDown:Byte);
  502.    VAR
  503.       X,X2:Integer;
  504.    BEGIN
  505.         IF GetPixel(L,Y)=C2 THEN
  506.            WHILE (L>0) AND (GetPixel(L-1,Y)=C2) DO
  507.                  Dec(L);
  508.         X:=L;
  509.         IF GetPixel(R,Y)=C2 THEN
  510.            WHILE (R<319) AND (GetPixel(R+1,Y)=C2) DO
  511.                  Inc(R);
  512.         WHILE X<=R DO
  513.         BEGIN
  514.              X2:=X;
  515.              IF GetPixel(X,Y)=C2 THEN
  516.              BEGIN
  517.                   WHILE (GetPixel(X+1,Y)=C2) AND (X<319) DO
  518.                         Inc(X);
  519.                   DrawLineH(X2,X,Y,C);
  520.                   IF UpDown=2 THEN
  521.                   BEGIN
  522.                        IF Y>0 THEN
  523.                           Suchen(X2,X,Y-1,2);
  524.                        IF Y<199 THEN
  525.                           IF (L>X2) AND (R<X) THEN
  526.                           BEGIN
  527.                                Suchen(X2,L-1,Y+1,1);
  528.                                Suchen(R+1,X,Y+1,1);
  529.                           END
  530.                           ELSE
  531.                           IF (L<=X2) AND (R<X) THEN
  532.                              Suchen(R+1,X,Y+1,1)
  533.                           ELSE
  534.                           IF (L>X2) AND (R>=X) THEN
  535.                              Suchen(X2,L-1,Y+1,1);
  536.                   END;
  537.                   IF UpDown=1 THEN
  538.                   BEGIN
  539.                        IF Y<199 THEN
  540.                           Suchen(X2,X,Y+1,1);
  541.                        IF Y>0 THEN
  542.                           IF (L>X2) AND (R<X) THEN
  543.                           BEGIN
  544.                                Suchen(X2,L-1,Y-1,2);
  545.                                Suchen(R+1,X,Y-1,2);
  546.                           END
  547.                           ELSE
  548.                           IF (L<=X2) AND (R<X) THEN
  549.                              Suchen(R+1,X,Y-1,2)
  550.                           ELSE
  551.                           IF (L>X2) AND (R>=X) THEN
  552.                              Suchen(X2,L-1,Y-1,2);
  553.                   END;
  554.              END;
  555.              Inc(X);
  556.         END;
  557.    END;
  558.  
  559. BEGIN
  560.      C2:=GetPixel(X,Y);
  561.      IF Y<>0 THEN
  562.         Dec(Y);
  563.      Suchen(X,X,Y,2);
  564.      Suchen(X,X,Y+1,1);
  565. END;
  566.  
  567. PROCEDURE Flood(X,Y:Integer; C,C2:Byte);  { Anfärben bis zur Randfarbe C2 }
  568.  
  569.    PROCEDURE Suchen(L,R,Y:Integer; UpDown:Byte);
  570.    VAR
  571.       X,X2:Integer;
  572.    BEGIN
  573.         IF GetPixel(L,Y)<>C2 THEN
  574.            WHILE (L>0) AND (GetPixel(L-1,Y)<>C2) DO
  575.                  Dec(L);
  576.         X:=L;
  577.         IF GetPixel(R,Y)<>C2 THEN
  578.            WHILE (R<319) AND (GetPixel(R+1,Y)<>C2) DO
  579.                  Inc(R);
  580.         WHILE X<=R DO
  581.         BEGIN
  582.              X2:=X;
  583.              IF GetPixel(X,Y)<>C2 THEN
  584.              BEGIN
  585.                   WHILE (GetPixel(X+1,Y)<>C2) AND (X<319) DO
  586.                         Inc(X);
  587.                   DrawLineH(X2,X,Y,C);
  588.                   IF UpDown=2 THEN
  589.                   BEGIN
  590.                        IF Y>0 THEN
  591.                           Suchen(X2,X,Y-1,2);
  592.                        IF Y<199 THEN
  593.                           IF (L>X2) AND (R<X) THEN
  594.                           BEGIN
  595.                                Suchen(X2,L-1,Y+1,1);
  596.                                Suchen(R+1,X,Y+1,1);
  597.                           END
  598.                           ELSE
  599.                           IF (L<=X2) AND (R<X) THEN
  600.                              Suchen(R+1,X,Y+1,1)
  601.                           ELSE
  602.                           IF (L>X2) AND (R>=X) THEN
  603.                              Suchen(X2,L-1,Y+1,1);
  604.                   END;
  605.                   IF UpDown=1 THEN
  606.                   BEGIN
  607.                        IF Y<199 THEN
  608.                           Suchen(X2,X,Y+1,1);
  609.                        IF Y>0 THEN
  610.                           IF (L>X2) AND (R<X) THEN
  611.                           BEGIN
  612.                                Suchen(X2,L-1,Y-1,2);
  613.                                Suchen(R+1,X,Y-1,2);
  614.                           END
  615.                           ELSE
  616.                           IF (L<=X2) AND (R<X) THEN
  617.                              Suchen(R+1,X,Y-1,2)
  618.                           ELSE
  619.                           IF (L>X2) AND (R>=X) THEN
  620.                              Suchen(X2,L-1,Y-1,2);
  621.                   END;
  622.              END;
  623.              Inc(X);
  624.         END;
  625.    END;
  626.  
  627. BEGIN
  628.      IF Y<>0 THEN
  629.         Dec(Y);
  630.      Suchen(X,X,Y,2);
  631.      Suchen(X,X,Y+1,1);
  632. END;
  633.  
  634. PROCEDURE MCGAOn;
  635. BEGIN
  636.      ASM
  637.         mov ah,$f
  638.         int $10
  639.         mov [offset oldmode],al
  640.      END;
  641.      ASM
  642.         mov ax,$13
  643.         int $10
  644.      END;
  645. END;
  646.  
  647. PROCEDURE MCGAOff;
  648. BEGIN
  649.      ASM
  650.         mov al,[offset oldmode]
  651.         xor ah,ah
  652.         int $10
  653.      END;
  654. END;
  655.  
  656. PROCEDURE FillPolygon(Size:Integer; VAR P1; C:Byte);
  657. TYPE
  658.     Vektor=RECORD
  659.                  X,Y,XMax,DX,DY,DZ,Z,Spalte:Integer;
  660.            END;
  661.     VekPoly=ARRAY[1..VekMax,1..2,1..2] OF Integer;
  662. VAR
  663.    P:ARRAY[1..VekMax,1..2] OF Integer ABSOLUTE P1;
  664.    Sp:VekPoly;
  665.    NF:Boolean;
  666.    V:ARRAY[1..VekMax] OF Vektor;
  667.    S:ARRAY[1..2*VekMax] OF Integer;
  668.    I,J,K,N,SX,YRMin,YRMax,YR,XMin,YMin,YMax,I2:Integer;
  669. BEGIN
  670.      IF Size>VekMax THEN
  671.         Exit;
  672.      K:=1;
  673.      FOR I:=1 TO Size DO
  674.      BEGIN
  675.           Sp[K,1,1]:=P[I,1];
  676.           Sp[K,1,2]:=P[I,2];
  677.           IF I=Size THEN
  678.           BEGIN
  679.                Sp[K,2,1]:=P[1,1];
  680.                Sp[K,2,2]:=P[1,2];
  681.           END
  682.           ELSE
  683.           BEGIN
  684.                Sp[K,2,1]:=P[I+1,1];
  685.                Sp[K,2,2]:=P[I+1,2];
  686.           END;
  687.           IF Sp[K,2,2]-Sp[K,1,2]<0 THEN
  688.           BEGIN
  689.                J:=Sp[K,2,1];
  690.                Sp[K,2,1]:=Sp[K,1,1];
  691.                Sp[K,1,1]:=J;
  692.                J:=Sp[K,2,2];
  693.                Sp[K,2,2]:=Sp[K,1,2];
  694.                Sp[K,1,2]:=J;
  695.           END;
  696.           Inc(K);
  697.      END;
  698.      YRMin:=199;
  699.      YRMax:=0;
  700.      FOR K:=1 TO Size DO
  701.          FOR I:=1 TO 2 DO
  702.          BEGIN
  703.               IF Sp[K,I,2]>YRMax THEN
  704.                  YRMax:=Sp[K,I,2];
  705.               IF Sp[K,I,2]<YRMin THEN
  706.                  YRMin:=Sp[K,I,2];
  707.          END;
  708.      IF YRMin<0 THEN
  709.         YRMin:=0;
  710.      IF YRMax>199 THEN
  711.         YRMax:=199;
  712.      FOR K:=1 TO Size DO
  713.          WITH V[K] DO
  714.          BEGIN
  715.               XMin:=Sp[K,1,1];
  716.               YMin:=Sp[K,1,2];
  717.               XMax:=Sp[K,2,1];
  718.               YMax:=Sp[K,2,2];
  719.               DX:=Abs(XMin-XMax);
  720.               DY:=Abs(YMin-YMax);
  721.               X:=XMin;
  722.               Y:=YMin;
  723.               IF XMin<XMax THEN
  724.                  Z:=1
  725.               ELSE Z:=-1;
  726.               IF DX>DY THEN
  727.                  I2:=DX
  728.               ELSE I2:=DY;
  729.               DZ:=I2 DIV 2;
  730.               Spalte:=XMin;
  731.          END;
  732.      FOR YR:=YRMin TO YRMax DO
  733.      BEGIN
  734.           N:=0;
  735.           FOR K:=1 TO Size DO
  736.               IF ((Sp[K,1,2]<=YR) AND (YR<SP[K,2,2])) OR ((YR=YRMax) AND (YRMax=Sp[K,2,2]) AND (YRMax<>Sp[K,1,2])) THEN
  737.               BEGIN
  738.                    WITH V[K] DO
  739.                    BEGIN
  740.                         Inc(N);
  741.                         S[N]:=X;
  742.                         SX:=X;
  743.                         REPEAT
  744.                               IF DZ<DX THEN
  745.                               BEGIN
  746.                                    DZ:=DZ+DY;
  747.                                    X:=X+Z;
  748.                               END;
  749.                               IF DZ>=DX THEN
  750.                               BEGIN
  751.                                    DZ:=DZ-DX;
  752.                                    Inc(Y);
  753.                               END;
  754.                               IF Y=YR THEN
  755.                                  SX:=X;
  756.                               Inc(Spalte,Z);
  757.                         UNTIL (Y>YR) OR (Spalte=XMax);
  758.                         Inc(N);
  759.                         S[N]:=SX;
  760.                    END;
  761.               END;
  762.           FOR I:=2 TO N DO
  763.               FOR K:=N DOWNTO I DO
  764.                   IF S[K-1]>S[K] THEN
  765.                   BEGIN
  766.                        J:=S[K-1];
  767.                        S[K-1]:=S[K];
  768.                        S[K]:=J;
  769.                   END;
  770.           K:=1;
  771.           WHILE K<=N DO
  772.           BEGIN
  773.                IF S[K]<0 THEN
  774.                   S[K]:=0;
  775.                IF S[K+3]>319 THEN
  776.                   S[K+3]:=319;
  777.                DrawLineH(S[K],S[K+3],YR,C);
  778.                K:=K+4;
  779.           END;
  780.      END;
  781. END;
  782.  
  783. PROCEDURE Ellipse(MX,MY,A,B:Integer; C:Byte);
  784. VAR
  785.    X,Y,X2,J:Integer;
  786. BEGIN
  787.      Dec(B);
  788.      X2:=A;
  789.      FOR Y:=0 TO B DO
  790.      BEGIN
  791.           X:=Trunc(A/B*Sqrt(Sqr(B)-Sqr(Y-0.5)));
  792.           FOR J:=X TO X2 DO
  793.           BEGIN
  794.                SetPixel(MX+J,MY+Y,C);
  795.                SetPixel(MX-J,MY+Y,C);
  796.                SetPixel(MX+J,MY-Y,C);
  797.                SetPixel(MX-J,MY-Y,C);
  798.           END;
  799.           X2:=X;
  800.      END;
  801.      Inc(B);
  802.      FOR J:=0 TO X DO
  803.      BEGIN
  804.           SetPixel(MX+J,MY+B,C);
  805.           SetPixel(MX-J,MY+B,C);
  806.           SetPixel(MX+J,MY-B,C);
  807.           SetPixel(MX-J,MY-B,C);
  808.      END;
  809. END;
  810.  
  811. PROCEDURE FillEllipse(MX,MY,A,B:Integer; C:Byte);
  812. VAR
  813.    X,Y,X2,J:Integer;
  814. BEGIN
  815.      Dec(B);
  816.      X2:=A;
  817.      DrawLineH(MX-A,MX+A,MY,C);
  818.      FOR Y:=1 TO B DO
  819.      BEGIN
  820.           X:=Trunc(A/B*Sqrt((Sqr(LongInt(B)))-Sqr(Y-0.5)));
  821.           DrawLineH(MX-X,MX+X,MY+Y,C);
  822.           DrawLineH(MX-X,MX+X,MY-Y,C);
  823.           X2:=X;
  824.      END;
  825. END;
  826.  
  827. PROCEDURE Circle(X,Y,R:Integer; C:Byte);
  828. BEGIN
  829.      Ellipse(X,Y,R,Trunc(R*X_zu_Y),C);
  830. END;
  831.  
  832. PROCEDURE FillCircle(X,Y,R:Integer; C:Byte);
  833. BEGIN
  834.      FillEllipse(X,Y,R,Round(R*X_zu_Y),C);
  835. END;
  836.  
  837. PROCEDURE RotateArray(VAR P; Count,MX,MY:Integer; Winkel:Real);
  838. TYPE
  839.     PunkteArray=ARRAY[1..16383,1..2] OF Integer;
  840. VAR
  841.    A:PunkteArray ABSOLUTE P;
  842.    I,X,Y:Integer;
  843.    CosWi,SinWi:Real;
  844. BEGIN
  845.      Winkel:=-Pi*Winkel/180;
  846.      CosWi:=Cos(Winkel);
  847.      SinWi:=Sin(Winkel);
  848.      FOR I:=1 TO Count DO
  849.      BEGIN
  850.           X:=A[I,1]-MX;
  851.           Y:=A[I,2]-MY;
  852.           A[I,1]:=Round(X*CosWi+Y*SinWi)+MX;
  853.           A[I,2]:=Round(-X*SinWi+Y*CosWi)+MY;
  854.      END;
  855. END;
  856.  
  857. PROCEDURE N4eck(N,X,Y,R1,R2:Integer; C:Byte);
  858. VAR
  859.    D:ARRAY[0..100] OF Word;
  860.    I,X1,Y1,X2,Y2:Integer;
  861.    Pi180:Real;
  862. BEGIN
  863.      Pi180:=Pi/180;
  864.      FOR I:=0 TO N DO
  865.          D[I]:=Round(Sin(Pi180*I/N*90)*10000);
  866.      X1:=Round(D[0]*R1/10000);
  867.      Y1:=Round(D[N]*R2/10000);
  868.      FOR I:=1 TO N DO
  869.      BEGIN
  870.           X2:=Round(D[I]*R1/10000);
  871.           Y2:=Round(D[N-I]*R2/10000);
  872.           DrawLine(X-X1,Y+Y1,X-X2,Y+Y2,C);
  873.           DrawLine(X+X1,Y+Y1,X+X2,Y+Y2,C);
  874.           DrawLine(X+X1,Y-Y1,X+X2,Y-Y2,C);
  875.           DrawLine(X-X1,Y-Y1,X-X2,Y-Y2,C);
  876.           X1:=X2;
  877.           Y1:=Y2;
  878.      END;
  879. END;
  880.  
  881. PROCEDURE Neck(N,X,Y,A,B:Integer; Drehen:Real);
  882. VAR
  883.    I:Integer;
  884.    Winkel,Wi:Real;
  885.    P:ARRAY[1..100,1..2] OF Integer;
  886. BEGIN
  887.      Winkel:=2*Pi/N;
  888.      Wi:=Winkel;
  889.      FOR I:=1 TO N DO
  890.      BEGIN
  891.           P[I,1]:=Round(A*Cos(Wi))+X;
  892.           P[I,2]:=Round(B*Sin(Wi))+Y;
  893.           Wi:=Wi+Winkel;
  894.      END;
  895.      IF Drehen<>0 THEN
  896.         RotateArray(P,N,X,Y,Drehen);
  897.      DrawPolygon(N,P,255);
  898. END;
  899.  
  900. PROCEDURE DrawRing(X,Y,R1,R2:Integer; C:Byte);
  901. TYPE
  902.     Arr52=ARRAY[1..52,1..2] OF Integer;
  903. CONST
  904.      D:ARRAY[1..14] OF Integer=(0,1205,2393,3546,4647,5681,6631,7485,8230,8855,9350,9709,9927,10000);
  905.      A:Arr52=(
  906.      (0,10000),(1205,9927),(2393,9709),(3546,9350),(4647,8855),(5681,8230),(6631,7485),
  907.      (7485,6631),(8230,5681),(8855,4647),(9350,3546),(9709,2393),(9927,1205),
  908.      (10000,0),(9927,-1205),(9709,-2393),(9350,-3546),(8855,-4647),(8230,-5681),(7485,-6631),
  909.      (6631,-7485),(5681,-8230),(4647,-8855),(3546,-9350),(2393,-9709),(1205,-9927),
  910.      (0,-10000),(-1205,-9927),(-2393,-9709),(-3546,-9350),(-4647,-8855),(-5681,-8230),(-6631,-7485),
  911.      (-7485,-6631),(-8230,-5681),(-8855,-4647),(-9350,-3546),(-9709,-2393),(-9927,-1205),
  912.      (-10000,0),(-9927,1205),(-9709,2393),(-9350,3546),(-8855,4647),(-8230,5681),(-7485,6631),
  913.      (-6631,7485),(-5681,8230),(-4647,8855),(-3546,9350),(-2393,9709),(-1205,9927));
  914. VAR
  915.    I,X1,Y1,X2,Y2:Integer;
  916.    A2:Arr52;
  917. BEGIN
  918.      A2:=A;
  919.      FOR I:=1 TO 52 DO
  920.      BEGIN
  921.           A2[I,1]:=X+Round(A2[I,1]/10000*R1);
  922.           A2[I,2]:=Y+Round(A2[I,2]/10000*R2);
  923.      END;
  924.      DrawPolygon(52,A2,C);
  925. END;
  926.  
  927. PROCEDURE FillRing(X,Y,R1,R2:Integer; C:Byte);
  928. TYPE
  929.     Arr52=ARRAY[1..52,1..2] OF Integer;
  930. CONST
  931.      D:ARRAY[1..14] OF Integer=(0,1205,2393,3546,4647,5681,6631,7485,8230,8855,9350,9709,9927,10000);
  932.      A:Arr52=(
  933.      (0,10000),(1205,9927),(2393,9709),(3546,9350),(4647,8855),(5681,8230),(6631,7485),
  934.      (7485,6631),(8230,5681),(8855,4647),(9350,3546),(9709,2393),(9927,1205),
  935.      (10000,0),(9927,-1205),(9709,-2393),(9350,-3546),(8855,-4647),(8230,-5681),(7485,-6631),
  936.      (6631,-7485),(5681,-8230),(4647,-8855),(3546,-9350),(2393,-9709),(1205,-9927),
  937.      (0,-10000),(-1205,-9927),(-2393,-9709),(-3546,-9350),(-4647,-8855),(-5681,-8230),(-6631,-7485),
  938.      (-7485,-6631),(-8230,-5681),(-8855,-4647),(-9350,-3546),(-9709,-2393),(-9927,-1205),
  939.      (-10000,0),(-9927,1205),(-9709,2393),(-9350,3546),(-8855,4647),(-8230,5681),(-7485,6631),
  940.      (-6631,7485),(-5681,8230),(-4647,8855),(-3546,9350),(-2393,9709),(-1205,9927));
  941. VAR
  942.    I,X1,Y1,X2,Y2:Integer;
  943.    A2:Arr52;
  944. BEGIN
  945.      A2:=A;
  946.      FOR I:=1 TO 52 DO
  947.      BEGIN
  948.           A2[I,1]:=X+Round(A2[I,1]/10000*R1);
  949.           A2[I,2]:=Y+Round(A2[I,2]/10000*R2);
  950.      END;
  951.      FillPolygon(52,A2,C);
  952. END;
  953.  
  954. PROCEDURE SetFrameColor(C:Byte);
  955. BEGIN
  956.      ASM
  957.         mov ax,$1001
  958.         mov bh,[bp+offset c]
  959.         int $10
  960.      END;
  961. END;
  962.  
  963. PROCEDURE RecTangle(X1,Y1,X2,Y2:Integer; C:Byte);
  964. BEGIN
  965.      DrawLineH(X1,X2,Y1,C);
  966.      DrawLineH(X1,X2,Y2,C);
  967.      DrawLineV(X1,Y1,Y2,C);
  968.      DrawLineV(X2,Y1,Y2,C);
  969. END;
  970.  
  971. PROCEDURE GetImage(X1,Y1,X2,Y2:Integer; VAR P);
  972. VAR
  973.    Data:ARRAY[0..64003] OF Byte ABSOLUTE P;
  974.    I,XS,YS:Word;
  975.    P2:Pointer ABSOLUTE P;
  976. BEGIN
  977.      XS:=X2-X1;
  978.      YS:=Y2-Y1;
  979.      Data[0]:=Lo(XS);
  980.      Data[1]:=Hi(XS);
  981.      Data[2]:=Lo(YS);
  982.      Data[3]:=Hi(YS);
  983.      FOR I:=0 TO YS DO
  984.          Move(Ptr($A000,(Y1+I)*320+X1)^,Data[(XS+1)*I+4],XS+1);
  985. END;
  986. {
  987. PROCEDURE PutImage(X1,Y1:Integer; VAR P);
  988. VAR
  989.    Data:ARRAY[0..64003] OF Byte ABSOLUTE P;
  990.    I,XS,YS:Word;
  991. BEGIN
  992.      XS:=Data[0]+Data[1] SHL 8;
  993.      YS:=Data[2]+Data[3] SHL 8;
  994.      FOR I:=0 TO YS DO
  995.          Move(Data[(XS+1)*I+4],Ptr($A000,(Y1+I)*320+X1)^,XS+1);
  996. END;
  997. }
  998.  
  999. PROCEDURE PutImage(X1,Y1:Integer; VAR P);
  1000. VAR
  1001.    Data:ARRAY[0..64003] OF Byte ABSOLUTE P;
  1002.    Adr,I,XS,YS:Word;
  1003.    DataDS,DataSI:Word;
  1004. BEGIN
  1005.      XS:=Data[0]+Data[1] SHL 8;
  1006.      YS:=Data[2]+Data[3] SHL 8;
  1007.      Adr:=Word(Y1)*320+X1;
  1008.      DataDS:=Seg(Data[4]);
  1009.      DataSI:=Ofs(Data[4]);
  1010.      ASM
  1011.         mov dx,ys
  1012.         inc dx
  1013.         mov bx,xs
  1014.         inc bx
  1015.         mov ax,$a000
  1016.         mov es,ax
  1017.         mov di,adr
  1018.         mov si,DataSI
  1019.         mov ax,DataDS
  1020.         push ds
  1021.         mov ds,ax
  1022.         cld
  1023. @1:     mov cx,bx
  1024.         rep movsb
  1025.         add di,320
  1026.         sub di,bx
  1027.         dec dx
  1028.         jnz @1
  1029.         pop ds
  1030.      END;
  1031. {
  1032.      FOR I:=0 TO YS DO
  1033.          Move(Data[(XS+1)*I+4],Ptr($A000,(Y1+I)*320+X1)^,XS+1);
  1034. }
  1035. END;
  1036.  
  1037. PROCEDURE PutImagePart(X1,Y1,XS2,YS2:Integer; VAR P);
  1038. VAR
  1039.    Data:ARRAY[0..64003] OF Byte ABSOLUTE P;
  1040.    Adr,I,XS,YS:Word;
  1041.    DataDS,DataSI:Word;
  1042. BEGIN
  1043.      XS:=Data[0]+Data[1] SHL 8+1;
  1044.      YS:=Data[2]+Data[3] SHL 8+1;
  1045.      IF (XS2<0) OR (XS2>XS) THEN
  1046.         XS2:=XS;
  1047.      IF (YS2<0) OR (YS2>YS) THEN
  1048.         YS2:=YS;
  1049.      Adr:=Word(Y1)*320+X1;
  1050.      DataDS:=Seg(Data[4]);
  1051.      DataSI:=Ofs(Data[4]);
  1052.      ASM
  1053.         mov dx,ys
  1054.         mov bx,xs2
  1055.         mov ax,$a000
  1056.         mov es,ax
  1057.         mov di,adr
  1058.         mov si,DataSI
  1059.         mov ax,DataDS
  1060.         mov cx,xs
  1061.         sub cx,xs2
  1062.         push ds
  1063.         mov ds,ax
  1064.         mov ax,cx
  1065.         cld
  1066. @1:     mov cx,bx
  1067.         rep movsb
  1068.         add di,320
  1069.         sub di,bx
  1070.         add si,ax
  1071.         dec dx
  1072.         jnz @1
  1073.         pop ds
  1074.      END;
  1075. {
  1076.      FOR I:=0 TO YS DO
  1077.          Move(Data[(XS+1)*I+4],Ptr($A000,(Y1+I)*320+X1)^,XS+1);
  1078. }
  1079. END;
  1080.  
  1081. PROCEDURE FillBlock(X1,Y1,X2,Y2:Integer; C:Byte);
  1082. VAR
  1083.    Y:Integer;
  1084. BEGIN
  1085.      FOR Y:=Y1 TO Y2 DO
  1086.          DrawLineH(X1,X2,Y,C);
  1087. END;
  1088.  
  1089. PROCEDURE ScrollLeft(X1,Y1,X2,Y2:Word);
  1090. BEGIN
  1091.      ASM
  1092.         push ds
  1093.         mov ax,$a000
  1094.         mov es,ax
  1095.         mov ds,ax
  1096.         mov si,[bp+offset y1]
  1097.         mov cx,[bp+offset y2]
  1098.         sub cx,si
  1099.         inc cx
  1100.         mov ax,320
  1101.         mul si
  1102.         mov bx,[bp+offset x1]
  1103.         add ax,bx
  1104.         mov dx,[bp+offset x2]
  1105.         sub dx,bx
  1106.         inc dx
  1107.         cld
  1108. @1:     mov bx,cx
  1109.         mov di,ax
  1110.         dec di
  1111.         mov si,ax
  1112.         mov cx,dx
  1113.         rep movsb
  1114.         mov cx,bx
  1115.         add ax,320
  1116.         loop @1
  1117.         pop ds
  1118.      END;
  1119. END;
  1120.  
  1121. PROCEDURE ScrollRight(X1,Y1,X2,Y2:Word);
  1122. BEGIN
  1123.      ASM
  1124.         push ds
  1125.         mov ax,$a000
  1126.         mov es,ax
  1127.         mov ds,ax
  1128.         mov si,[bp+offset y1]
  1129.         mov cx,[bp+offset y2]
  1130.         sub cx,si
  1131.         inc cx
  1132.         mov ax,320
  1133.         mul si
  1134.         mov bx,[bp+offset x1]
  1135.         mov dx,[bp+offset x2]
  1136.         add ax,dx
  1137.         sub dx,bx
  1138.         inc dx
  1139.         std
  1140. @1:     mov bx,cx
  1141.         mov di,ax
  1142.         mov si,ax
  1143.         dec si
  1144.         mov cx,dx
  1145.         rep movsb
  1146.         mov cx,bx
  1147.         add ax,320
  1148.         loop @1
  1149.         cld
  1150.         pop ds
  1151.      END;
  1152. END;
  1153.  
  1154. PROCEDURE ScrollUp(X1,Y1,X2,Y2:Word);
  1155. BEGIN
  1156.      ASM
  1157.         push ds
  1158.         mov ax,$a000
  1159.         mov es,ax
  1160.         mov ds,ax
  1161.         mov si,[bp+offset y1]
  1162.         mov cx,[bp+offset y2]
  1163.         sub cx,si
  1164.         inc cx
  1165.         mov ax,320
  1166.         mul si
  1167.         mov bx,[bp+offset x1]
  1168.         add ax,bx
  1169.         mov dx,[bp+offset x2]
  1170.         sub dx,bx
  1171.         inc dx
  1172.         cld
  1173. @1:     mov bx,cx
  1174.         mov di,ax
  1175.         sub di,320
  1176.         mov si,ax
  1177.         mov cx,dx
  1178.         rep movsb
  1179.         mov cx,bx
  1180.         add ax,320
  1181.         loop @1
  1182.         pop ds
  1183.      END;
  1184. END;
  1185.  
  1186. PROCEDURE ScrollDown(X1,Y1,X2,Y2:Word);
  1187. BEGIN
  1188.      ASM
  1189.         push ds
  1190.         mov ax,$a000
  1191.         mov es,ax
  1192.         mov ds,ax
  1193.         mov si,[bp+offset y1]
  1194.         mov cx,[bp+offset y2]
  1195.         mov ax,320
  1196.         mul cx
  1197.         sub cx,si
  1198.         inc cx
  1199.         mov bx,[bp+offset x1]
  1200.         mov dx,[bp+offset x2]
  1201.         add ax,bx
  1202.         sub dx,bx
  1203.         inc dx
  1204.         cld
  1205. @1:     mov bx,cx
  1206.         mov di,ax
  1207.         mov si,ax
  1208.         sub si,320
  1209.         mov cx,dx
  1210.         rep movsb
  1211.         mov cx,bx
  1212.         sub ax,320
  1213.         loop @1
  1214.         pop ds
  1215.      END;
  1216. END;
  1217.  
  1218. PROCEDURE Scroll(Direction:Byte; X1,Y1,X2,Y2:Word);
  1219. BEGIN
  1220.      CASE Direction OF
  1221.           Up:ScrollUp(X1,Y1,X2,Y2);
  1222.           Right:ScrollRight(X1,Y1,X2,Y2);
  1223.           Down:ScrollDown(X1,Y1,X2,Y2);
  1224.           Left:ScrollLeft(X1,Y1,X2,Y2);
  1225.      END;
  1226. END;
  1227.  
  1228. PROCEDURE SwitchOff; ASSEMBLER;
  1229. ASM
  1230.    mov dx,$3c4
  1231.    mov al,1
  1232.    out dx,al
  1233.    inc dx
  1234.    in al,dx
  1235.    or al,$20
  1236.    out dx,al
  1237. END;
  1238.  
  1239. PROCEDURE SwitchOn; ASSEMBLER;
  1240. ASM
  1241.    mov dx,$3c4
  1242.    mov al,1
  1243.    out dx,al
  1244.    inc dx
  1245.    in al,dx
  1246.    and al,$df
  1247.    out dx,al
  1248. END;
  1249.  
  1250. PROCEDURE LoadPalette(DateiName:String);
  1251. VAR
  1252.    Datei:File;
  1253.    RGB:ARRAY[0..255,1..3] OF Byte;
  1254.    I:Byte;
  1255. BEGIN
  1256.      Assign(Datei,DateiName+'.PAL');
  1257.      Reset(Datei,1);
  1258.      BlockRead(Datei,RGB,768);
  1259.      SwitchOff;
  1260.      FOR I:=0 TO 255 DO
  1261.          SetColor(I,RGB[I,1],RGB[I,2],RGB[I,3]);
  1262.      SwitchOn;
  1263. END;
  1264.  
  1265. PROCEDURE SavePalette(DateiName:String);
  1266. VAR
  1267.    Datei:File;
  1268.    RGB:ARRAY[0..255,1..3] OF Byte;
  1269.    I:Byte;
  1270. BEGIN
  1271.      Assign(Datei,DateiName+'.PAL');
  1272.      Rewrite(Datei,1);
  1273.      FOR I:=0 TO 255 DO
  1274.          GetColor(I,RGB[I,1],RGB[I,2],RGB[I,3]);
  1275.      BlockWrite(Datei,RGB,768);
  1276. END;
  1277.  
  1278. PROCEDURE LoadScreen(DateiName:String);
  1279. VAR
  1280.    Datei:File;
  1281.    RGB:ARRAY[0..255,1..3] OF Byte;
  1282.    I:Byte;
  1283. BEGIN
  1284.      Assign(Datei,DateiName+'.BLD');
  1285.      Reset(Datei,1);
  1286.      BlockRead(Datei,RGB,768);
  1287.      SwitchOff;
  1288.      FOR I:=0 TO 255 DO
  1289.          SetColor(I,RGB[I,1],RGB[I,2],RGB[I,3]);
  1290.      BlockRead(Datei,Ptr($A000,0)^,64000);
  1291.      SwitchOn;
  1292.      Close(Datei);
  1293. END;
  1294.  
  1295. PROCEDURE SaveScreen(DateiName:String);
  1296. VAR
  1297.    Datei:File;
  1298.    RGB:ARRAY[0..255,1..3] OF Byte;
  1299.    I:Byte;
  1300. BEGIN
  1301.      Assign(Datei,DateiName+'.BLD');
  1302.      Rewrite(Datei,1);
  1303.      FOR I:=0 TO 255 DO
  1304.          GetColor(I,RGB[I,1],RGB[I,2],RGB[I,3]);
  1305.      BlockWrite(Datei,RGB,768);
  1306.      BlockWrite(Datei,Ptr($A000,0)^,64000);
  1307.      Close(Datei);
  1308. END;
  1309.  
  1310. PROCEDURE BCircle(X,Y,R:Integer; C:Byte);
  1311. VAR
  1312.    XX4,XX,YY,D:Integer;
  1313. BEGIN
  1314.      XX:=0;
  1315.      YY:=R;
  1316.      D:=3-(2*R);
  1317.      WHILE XX<=YY DO
  1318.      BEGIN
  1319.           SetPixel(X+XX,Y+YY,C);
  1320.           SetPixel(X-XX,Y+YY,C);
  1321.           SetPixel(X+XX,Y-YY,C);
  1322.           SetPixel(X-XX,Y-YY,C);
  1323.           SetPixel(X+YY,Y+XX,C);
  1324.           SetPixel(X-YY,Y+XX,C);
  1325.           SetPixel(X+YY,Y-XX,C);
  1326.           SetPixel(X-YY,Y-XX,C);
  1327.           XX4:=XX SHL 2;
  1328.           IF D<0 THEN
  1329.              Inc(D,XX4+6)
  1330.           ELSE
  1331.           BEGIN
  1332.                Inc(D,XX4-YY SHL 2+10);
  1333.                Dec(YY);
  1334.           END;
  1335.           Inc(XX);
  1336.      END;
  1337. END;
  1338.  
  1339. PROCEDURE BFillCircle(X,Y,R:Integer; C:Byte);
  1340. VAR
  1341.    XX4,XX,YY,D:Integer;
  1342. BEGIN
  1343.      XX:=0;
  1344.      YY:=R;
  1345.      D:=3-(2*R);
  1346.      WHILE XX<=YY DO
  1347.      BEGIN
  1348.           DrawLineH(X-XX,X+XX,Y+YY,C);
  1349.           DrawLineH(X-XX,X+XX,Y-YY,C);
  1350.           DrawLineH(X-YY,X+YY,Y+XX,C);
  1351.           DrawLineH(X-YY,X+YY,Y-XX,C);
  1352.           XX4:=XX SHL 2;
  1353.           IF D<0 THEN
  1354.              Inc(D,XX4+6)
  1355.           ELSE
  1356.           BEGIN
  1357.                Inc(D,XX4-YY SHL 2+10);
  1358.                Dec(YY);
  1359.           END;
  1360.           Inc(XX);
  1361.      END;
  1362. END;
  1363.  
  1364. PROCEDURE Split(Row:Integer);
  1365. BEGIN
  1366.      ASM
  1367.         mov dx,$3d4
  1368.         mov ax,row
  1369.         mov bh,ah
  1370.         mov bl,ah
  1371.         and bx,201h
  1372.         mov cl,4
  1373.         shl bx,cl
  1374.         mov ah,al
  1375.         mov al,18h
  1376.         out dx,ax
  1377.         mov al,7
  1378.         cli
  1379.         out dx,al
  1380.         inc dx
  1381.         in al,dx
  1382.         sti
  1383.         dec dx
  1384.         mov ah,al
  1385.         and ah,0efh
  1386.         or ah,bl
  1387.         mov al,7
  1388.         out dx,ax
  1389.         mov al,9
  1390.         cli
  1391.         out dx,al
  1392.         inc dx
  1393.         in al,dx
  1394.         sti
  1395.         dec dx
  1396.         mov ah,al
  1397.         and ah,0bfh
  1398.         shl bh,1
  1399.         shl bh,1
  1400.         or ah,bh
  1401.         mov al,9
  1402.         out dx,ax
  1403.      END;
  1404. END;
  1405.  
  1406. PROCEDURE ScrollText(Nr:Word);
  1407. BEGIN
  1408.      ASM
  1409.         mov ax,nr
  1410.         push es
  1411.         push cx
  1412.         push dx
  1413.         mov cx,$40
  1414.         mov es,cx
  1415.         mov cl,es:[$85]
  1416.         div cl
  1417.         mov cx,ax
  1418.         mov dx,es:[$63]
  1419.         push dx
  1420.         mov al,$13
  1421.         cli
  1422.         out dx,al
  1423.         jmp @1
  1424. @1:     inc dx
  1425.         in al,dx
  1426.         sti
  1427.         mul cl
  1428.         shl ax,1
  1429.         mov es:[$4e],ax
  1430.         pop dx
  1431.         mov cl,al
  1432.         mov al,$c
  1433.         out dx,ax
  1434.         jmp @2
  1435. @2:     mov al,$d
  1436.         mov ah,cl
  1437.         out dx,ax
  1438.         jmp @3
  1439. @3:     mov ah,ch
  1440.         mov al,8
  1441.         out dx,ax
  1442.         pop dx
  1443.         pop cx
  1444.         pop es
  1445.      END;
  1446. END;
  1447.  
  1448. PROCEDURE SetStart(S:Word);
  1449. BEGIN
  1450.      ASM
  1451.         mov bx,s
  1452.         mov dx,$3d4
  1453.         mov al,$c
  1454.         mov ah,bh
  1455.         out dx,ax
  1456.         inc ax
  1457.         mov ah,bl
  1458.         out dx,ax
  1459.      END;
  1460. END;
  1461.  
  1462. PROCEDURE VerticalRetrace;
  1463. BEGIN
  1464.      ASM
  1465.         mov dx,3dah
  1466. @1:     in al,dx
  1467.         test al,8
  1468.         jz @1
  1469. @2:     in al,dx
  1470.         test al,8
  1471.         jnz @2
  1472.      END;
  1473. END;
  1474.  
  1475. PROCEDURE WaitScreen;
  1476. BEGIN
  1477.      ASM
  1478.         mov dx,3dah
  1479. @1:     in al,dx
  1480.         test al,8
  1481.         jnz @1
  1482.      END;
  1483. END;
  1484.  
  1485. PROCEDURE WaitRetrace;
  1486. BEGIN
  1487.      ASM
  1488.         mov dx,3dah
  1489. @1:     in al,dx
  1490.         test al,8
  1491.         jz @1
  1492.      END;
  1493. END;
  1494.  
  1495. PROCEDURE SetOffset(B:Byte);
  1496. BEGIN
  1497.      ASM
  1498.         mov dx,$3d4
  1499.         mov al,$13
  1500.         mov ah,b
  1501.         out dx,ax
  1502.      END;
  1503. END;
  1504.  
  1505. PROCEDURE LoadSprite(DateiName:String; VAR P);
  1506. VAR
  1507.    Datei:File;
  1508.    Size,I:Word;
  1509.    P2:Pointer ABSOLUTE P;
  1510. BEGIN
  1511.      Assign(Datei,DateiName+'.SPR');
  1512.      Reset(Datei,1);
  1513.      Size:=FileSize(Datei);
  1514.      GetMem(P2,Size+15);
  1515.      IF Ofs(P2^)<>0 THEN
  1516.         P2:=Ptr(Seg(P2^)+1,0);
  1517.      BlockRead(Datei,P2^,Size);
  1518.      Close(Datei);
  1519. END;
  1520.  
  1521. PROCEDURE SaveSprite(DateiName:String; VAR P);
  1522. VAR
  1523.    A:ARRAY[-4..32000] OF Byte ABSOLUTE P;
  1524.    Datei:File;
  1525.    Size,I:Word;
  1526.    XS,YS:Word;
  1527. BEGIN
  1528.      XS:=A[-4]+A[-3] SHL 8;
  1529.      YS:=A[-2]+A[-1] SHL 8;
  1530.      Assign(Datei,DateiName+'.SPR');
  1531.      Rewrite(Datei,1);
  1532.      Size:=(XS+1)*(YS+1)+4;
  1533.      BlockWrite(Datei,A,Size);
  1534.      Close(Datei);
  1535. END;
  1536.  
  1537. PROCEDURE FillScreen(C:Byte);
  1538. BEGIN
  1539.      ASM
  1540.         mov ax,$a000
  1541.         mov es,ax
  1542.         mov al,c
  1543.         mov ah,al
  1544.         cld
  1545.         xor di,di
  1546.         mov cx,32000
  1547.         rep stosw
  1548.      END;
  1549. END;
  1550.  
  1551. PROCEDURE Unchain;
  1552. BEGIN
  1553.      PortW[$3C4]:=$0604;
  1554.      PortW[$3D4]:=$0014;
  1555.      PortW[$3D4]:=$E317;
  1556.      PortW[$3C4]:=$0F02;
  1557. END;
  1558.  
  1559. PROCEDURE Rechain;
  1560. BEGIN
  1561.      PortW[$3C4]:=$0E04;
  1562.      PortW[$3C4]:=$0100;
  1563.      PortW[$3C4]:=$0300;
  1564.      PortW[$3D4]:=$4014;
  1565.      PortW[$3D4]:=$A317;
  1566. END;
  1567.  
  1568. PROCEDURE ClearScreen;
  1569. BEGIN
  1570.      PortW[$3C4]:=$0F02;
  1571.      ASM
  1572.         mov ax,$a000
  1573.         mov es,ax
  1574.         mov cx,16383
  1575.         db $66
  1576.         xor ax,ax
  1577.         xor di,di
  1578.         cld
  1579.         db $66
  1580.         rep stosw
  1581.      END;
  1582. END;
  1583.  
  1584. PROCEDURE SetChain4;
  1585. BEGIN
  1586.      Port[$3CE]:=$05;
  1587.      Port[$3CF]:=Port[$3CF] AND $EF;
  1588.      Port[$3CE]:=$06;
  1589.      Port[$3CF]:=Port[$3CF] AND $FD;
  1590.      Port[$3C4]:=$04;
  1591.      Port[$3C5]:=Port[$3C5] AND $F7;
  1592.      Port[$3D4]:=$14;
  1593.      Port[$3D5]:=Port[$3D5] AND $BF;
  1594.      Port[$3D4]:=$17;
  1595.      Port[$3D5]:=Port[$3D5] OR $40;
  1596. END;
  1597.  
  1598. PROCEDURE ClearChain4;
  1599. BEGIN
  1600.      ASM
  1601.         mov ax,$a000
  1602.         mov es,ax
  1603.         mov cx,32768
  1604.         xor di,di
  1605.         cld
  1606.         xor ax,ax
  1607.         rep stosw
  1608.      END;
  1609. END;
  1610.  
  1611. PROCEDURE CharHeight(B:Byte);
  1612. BEGIN
  1613.      Port[$3D4]:=$09;
  1614.      Port[$3D5]:=(Port[$3D5] AND $E0) OR B;
  1615. END;
  1616.  
  1617. PROCEDURE Wait4Line;
  1618. BEGIN
  1619.      ASM
  1620.         mov dx,$3da
  1621. @1:     in al,dx
  1622.         test al,1
  1623.         jnz @1
  1624. @2:     in al,dx
  1625.         test al,1
  1626.         jz @2
  1627.      END;
  1628. END;
  1629.  
  1630. PROCEDURE CLI; ASSEMBLER;
  1631. ASM
  1632.    cli
  1633. END;
  1634.  
  1635. PROCEDURE STI; ASSEMBLER;
  1636. ASM
  1637.    sti
  1638. END;
  1639.  
  1640. PROCEDURE SetWriteMap(Map:Byte);
  1641. BEGIN
  1642.      Port[$3C4]:=2;
  1643.      Port[$3C5]:=Map;
  1644. END;
  1645.  
  1646. PROCEDURE PutImage4(X1,Y1:Integer; VAR P);
  1647. VAR
  1648.    Data:ARRAY[0..64003] OF Byte ABSOLUTE P;
  1649.    Adr,I,J,K,XS,YS:Word;
  1650.    DataDS,DataSI:Word;
  1651. BEGIN
  1652.      XS:=Data[0]+Data[1] SHL 8;
  1653.      YS:=Data[2]+Data[3] SHL 8;
  1654.      DataDS:=Seg(Data);
  1655.      FOR J:=0 TO YS DO
  1656.      BEGIN
  1657.           DataSI:=Ofs(Data)+4+(XS+1)*J;
  1658.           FOR K:=0 TO 3 DO
  1659.           BEGIN
  1660.                Adr:=Word(Y1+J)*80+(X1+K) SHR 2;
  1661.                SetWriteMap(1 SHL ((X1+K) AND 3));
  1662.                ASM
  1663.                   push ds
  1664.                   mov ax,$a000
  1665.                   mov es,ax
  1666.                   mov di,adr
  1667.                   mov cx,xs
  1668.                   shr cx,2
  1669.                   inc cx
  1670.                   mov si,datasi
  1671.                   mov ax,datads
  1672.                   mov ds,ax
  1673.                   mov bx,3
  1674.                   cld
  1675. @1:               movsb
  1676.                   add si,bx
  1677.                   loop @1
  1678.                   pop ds
  1679.                END;
  1680.                Inc(DataSI);
  1681.           END;
  1682.      END;
  1683. END;
  1684.  
  1685. FUNCTION SpriteXSize(Sprite:Pointer):Word;
  1686. BEGIN
  1687.      ASM
  1688.         push ds
  1689.         lds si,sprite
  1690.         lodsw
  1691.         inc ax
  1692.         mov @result,ax
  1693.         pop ds
  1694.      END;
  1695. END;
  1696.  
  1697. FUNCTION SpriteYSize(Sprite:Pointer):Word;
  1698. BEGIN
  1699.      ASM
  1700.         push ds
  1701.         lds si,sprite
  1702.         lodsw
  1703.         lodsw
  1704.         inc ax
  1705.         mov @result,ax
  1706.         pop ds
  1707.      END;
  1708. END;
  1709.  
  1710. FUNCTION SpriteSize(Sprite:Pointer):Word;
  1711. BEGIN
  1712.      ASM
  1713.         push ds
  1714.         lds si,sprite
  1715.         lodsw
  1716.         inc ax
  1717.         mov bx,ax
  1718.         lodsw
  1719.         inc ax
  1720.         mul bx
  1721.         add ax,4
  1722.         mov @result,ax
  1723.         pop ds
  1724.      END;
  1725. END;
  1726.  
  1727. PROCEDURE SetWriteMode(M:Byte);
  1728. BEGIN
  1729.      Port[$3CE]:=$05;
  1730.      Port[$3CF]:=(Port[$3CF] AND $FC) OR (M AND 3);
  1731. END;
  1732.  
  1733. PROCEDURE SetModeNr(Nr:Word);
  1734. BEGIN
  1735.      ASM
  1736.         mov ax,nr
  1737.         int $10
  1738.      END;
  1739. END;
  1740.  
  1741. PROCEDURE Set16Pal(Nr:Byte);
  1742. VAR
  1743.    I:Byte;
  1744. BEGIN
  1745.      I:=Port[$3DA];
  1746.      Port[$3C0]:=$34;
  1747.      Port[$3C0]:=Nr;
  1748. END;
  1749.  
  1750. PROCEDURE Init16Pal;
  1751. VAR
  1752.    I:Byte;
  1753. BEGIN
  1754.      I:=Port[$3DA];
  1755.      FOR I:=0 TO 15 DO
  1756.      BEGIN
  1757.           Port[$3C0]:=I;
  1758.           Port[$3C0]:=I;
  1759.      END;
  1760.      Port[$3C0]:=$10;
  1761.      Port[$3C0]:=$81;
  1762.      Set16Pal(0);
  1763. END;
  1764.  
  1765. PROCEDURE Init13X;
  1766. BEGIN
  1767.      MCGAOn;
  1768.      Unchain;
  1769. END;
  1770.  
  1771. PROCEDURE TextMode;
  1772. BEGIN
  1773.      ASM
  1774.         mov ax,3
  1775.         int 10h
  1776.      END;
  1777. END;
  1778.  
  1779. PROCEDURE SetLineRepeat(Nr:Byte);
  1780. BEGIN
  1781.      Port[$3C4]:=9;
  1782.      Port[$3C5]:=(Port[$3C5] AND $F0)+Nr;
  1783. END;
  1784.  
  1785. PROCEDURE SetReadMap(Map:Byte);
  1786. BEGIN
  1787.      Port[$3C4]:=4;
  1788.      Port[$3C5]:=Map;
  1789. END;
  1790.  
  1791. PROCEDURE DrawLineH4(X1,X2,Y1:Word; C:Byte);
  1792. VAR
  1793.    Adresse:LongInt;
  1794.  
  1795.    PROCEDURE DrawLineH4X(X1,X2,Y1:Word; C:Byte);
  1796.    BEGIN
  1797.         ASM
  1798.            mov ax,$a000
  1799.            mov es,ax
  1800.            mov ax,[bp+offset y1]
  1801.            mov bx,800
  1802.            mul bx
  1803.            add ax,[bp+offset x1]
  1804.            adc dx,0
  1805.            mov di,$3cd
  1806.            xchg di,ax
  1807.            xchg ax,dx
  1808.            or al,$40
  1809.            out dx,al
  1810.            mov bx,[bp+offset x1]
  1811.            mov dx,[bp+offset x2]
  1812.            inc dx
  1813.            mov cx,dx
  1814.            sub cx,bx
  1815.            shr cx,1
  1816.            mov al,[bp+offset c]
  1817.            mov ah,al
  1818.            ror bx,1
  1819.            jnb @2
  1820.            stosb
  1821.            ror dx,1
  1822.            jnb @3
  1823.            dec cx
  1824.    @3:     rol dx,1
  1825.    @2:     rep
  1826.            stosw
  1827.            ror dx,1
  1828.            jnb @4
  1829.            stosb
  1830.    @4:  END;
  1831.    END;
  1832.  
  1833. BEGIN
  1834.      Adresse:=LongInt(Y1)*800;
  1835.      IF (Adresse+X1) SHR 16<>(Adresse+X2) SHR 16 THEN
  1836.      BEGIN
  1837.           DrawLineH4X(X1,65535-Word(Y1*800),Y1,C);
  1838.           DrawLineH4X(Word(-Word(Y1*800)),X2,Y1,C);
  1839.      END
  1840.      ELSE DrawLineH4X(X1,X2,Y1,C);
  1841. END;
  1842.  
  1843. PROCEDURE DrawLineV4(X1,Y1,Y2:Word; C:Byte);
  1844. VAR
  1845.    Adresse:LongInt;
  1846.    Y:Word;
  1847.    A:Byte;
  1848.  
  1849.    PROCEDURE DrawLineV4X(X1,Y1,Y2:Word; C:Byte);
  1850.    BEGIN
  1851.         ASM
  1852.            mov bx,[bp+offset x1]
  1853.            mov ax,[bp+offset y1]
  1854.            mov cx,800
  1855.            mul cx
  1856.            add ax,bx
  1857.            adc dx,0
  1858.            mov di,$3cd
  1859.            xchg di,ax
  1860.            xchg ax,dx
  1861.            or al,$40
  1862.            out dx,al
  1863.            mov dx,[bp+offset y2]
  1864.            mov cx,$a000
  1865.            mov es,cx
  1866.            mov cx,dx
  1867.            sub cx,[bp+offset y1]
  1868.            inc cx
  1869.            mov al,[bp+offset c]
  1870.            mov bx,799
  1871.    @2:     stosb
  1872.            add di,bx
  1873.            loop @2
  1874.         END;
  1875.    END;
  1876.  
  1877. BEGIN
  1878.      Y:=Y1;
  1879.      WHILE (LongInt(Y)*800+X1) SHR 16<>(LongInt(Y2)*800+X1) SHR 16 DO
  1880.      BEGIN
  1881.           A:=(LongInt(Y)*800+X1) SHR 16;
  1882.           DrawLineV4X(X1,Y,(LongInt(A+1)*65536-1-X1) DIV 800,C);
  1883.           Y:=(LongInt(A+1)*65536-1-X1) DIV 800+1;
  1884.      END;
  1885.      DrawLineV4X(X1,Y,Y2,C);
  1886. END;
  1887.  
  1888. PROCEDURE SetHorizOfs(Count:Byte);
  1889. BEGIN
  1890.      Port[$3C0]:=$13;
  1891.      Port[$3C0]:=Count SHL 1;
  1892. END;
  1893.  
  1894. {
  1895. PROCEDURE SetReg(Reg:Word; Index,Value:Byte);
  1896. VAR
  1897.    B:Byte;
  1898. BEGIN
  1899.      CASE Reg OF
  1900.           $3C0:BEGIN
  1901.                     B:=Port[$3DA];
  1902.                     Port[$3C0]:=Index OR $20;
  1903. }
  1904. END.
  1905.